home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d13 / oct90.arc / FENCE.LSP next >
Encoding:
Text File  |  1990-11-01  |  6.4 KB  |  168 lines
  1. ; FENCE.LSP   [Article Figure 2]   (c)1990, Tony Sheving
  2.  
  3. (defun fence ( / boundry ptlist xlist ylist cnt etype pt lowx highx
  4.                  lowy highy pt1 sset elist ptcnt intcnt pt2 pt3 pt4)
  5.   (setq boundry (entget (car (entsel "Select polyline boundary: ")))
  6.         ptlist ()
  7.         xlist ()
  8.         ylist ()
  9.         cnt -1)
  10.   (if boundry (setq etype (cdr (assoc 0 boundry))))
  11.   (if (= etype "POLYLINE")
  12.     (if (= (cdr (assoc 70 boundry )) 1)
  13.       (while (and (/= (cdr (assoc 0 boundry)) "SEQEND")
  14.                   (setq boundry (entget (entnext (cdr (assoc -1 boundry))))))
  15.         (if (cdr (assoc 10 boundry))
  16.           (progn
  17.             (setq lastpt hilite
  18.                   hilite (cdr (assoc 10 boundry)))
  19.             (if lastpt (grdraw hilite lastpt 1 -1))
  20.             (setq ptlist (cons (cdr (assoc 10 boundry)) ptlist))
  21.           ) ;end progn
  22.         ) ;end if 
  23.       ) ;end while
  24.       (prompt "\nBoundary is not a closed polyline.\n")
  25.     )
  26.     (prompt "\nBoundary is not a polyline.\n")
  27.   )
  28.   (prompt "\nPlease wait... checking for entities within boundary.\n")
  29.   (foreach pt ptlist (setq xlist (cons (car pt) xlist)))
  30.   (foreach pt ptlist (setq ylist (cons (cadr pt) ylist)))
  31.   (setq lowx (apply 'min xlist) highx (apply 'max xlist)
  32.         lowy (apply 'min ylist) highy (apply 'max ylist)
  33.         pt1 (list (- lowx 10000.0)(- lowy 10000.0))
  34.         entset (ssget "C" (list lowx lowy) (list highx highy)))
  35.   (ssdel (cdr (assoc -1 boundry)) entset)
  36.   (setq sset (sslength entset))
  37.   (repeat sset
  38.     (setq elist (entget (ssname entset (setq cnt (1+ cnt))))
  39.           etype (cdr (assoc 0 elist)))
  40.     (cond 
  41.       ((or (= etype "INSERT")(= etype "POINT")(= etype "TEXT"))
  42.         (setq ptcnt 0 intcnt 0
  43.               pt2 (cdr (assoc 10 elist))
  44.               pt3 (nth 0 ptlist)
  45.               pt4 (nth (1- (length ptlist)) ptlist))
  46.         (repeat (length ptlist)
  47.           (if (inters pt1 pt2 pt3 pt4) (setq intcnt (1+ intcnt)))
  48.           (setq pt3 (nth ptcnt ptlist)
  49.                 ptcnt (1+ ptcnt)
  50.                 pt4 (nth ptcnt ptlist))
  51.         )
  52.         (if (or (= intcnt 0) (= (rem intcnt 2) 0))
  53.           (progn
  54.             (ssdel (ssname entset cnt) entset)
  55.             (setq cnt (1- cnt))
  56.           )
  57.         )
  58.       ) ;end cond insert or point or text
  59.  
  60.       ((= etype "LINE")
  61.         (setq ptcnt 0 intcnt 0 delflag nil
  62.               pt2 (cdr (assoc 10 elist))
  63.               pt2a (cdr (assoc 11 elist))
  64.               pt3 (nth 0 ptlist)
  65.               pt4 (nth (1- (length ptlist)) ptlist))
  66.         (repeat (length ptlist) ; check for intersections between line & pline
  67.           (if (and (= delflag nil) (inters pt2 pt2a pt3 pt4))
  68.             (progn
  69.               (ssdel (ssname entset cnt) entset)
  70.               (setq cnt (1- cnt)
  71.                     delflag t)
  72.             ) ;end progn
  73.             (progn
  74.               (setq pt3 (nth ptcnt ptlist)
  75.                     ptcnt (1+ ptcnt)
  76.                     pt4 (nth ptcnt ptlist))
  77.             ) ;end progn
  78.           ) ;end if intersection
  79.         ) ;end repeat
  80.         (if (= delflag nil)
  81.           (progn
  82.             (setq ptcnt 0 intcnt 0
  83.                   pt3 (nth 0 ptlist)
  84.                   pt4 (nth (1- (length ptlist)) ptlist))
  85.             (repeat (length ptlist)  ;check intersections of 1st point of line
  86.               (if (inters pt1 pt2 pt3 pt4) (setq intcnt (1+ intcnt)))
  87.               (setq pt3 (nth ptcnt ptlist)
  88.                     ptcnt (1+ ptcnt)
  89.                     pt4 (nth ptcnt ptlist))
  90.             ) ;end repeat
  91.             (if (or (= intcnt 0) (= (rem intcnt 2) 0)) ;if intersect even number
  92.               (progn ; then 1st point of line is not within boundary
  93.                 (ssdel (ssname entset cnt) entset)
  94.                 (setq cnt (1- cnt) delflag t)
  95.               )
  96.               (setq delflag nil)
  97.             ) ;enf if even number of intersections
  98.           ) ;end progn if delflag set
  99.         ) ;end if
  100.       ) ;end cond line
  101.  
  102.       ((= etype "POLYLINE")
  103.         (setq pt2list ())
  104.         (while (and (/= (cdr (assoc 0 elist)) "SEQEND")
  105.                     (setq elist (entget (entnext (cdr (assoc -1 elist))))))
  106.           (if (cdr (assoc 10 elist))
  107.             (setq pt2list (cons (cdr (assoc 10 elist)) pt2list))
  108.           ) ;end if 
  109.         ) ;end while
  110.         (setq ptcnt 0 pt2cnt 0 intcnt 0 delflag nil
  111.               pt2 (nth 0 pt2list)
  112.               pt2a (nth (1- (length pt2list)) pt2list))
  113.         (repeat (length pt2list)
  114.           (setq pt3 (nth 0 ptlist)
  115.                 pt4 (nth (1- (length ptlist)) ptlist))
  116.           (repeat (length ptlist) ; check for intersection between pline & pline
  117.             (if (and (= delflag nil) (inters pt2 pt2a pt3 pt4))
  118.               (progn
  119.                 (ssdel (ssname entset cnt) entset)
  120.                 (setq cnt (1- cnt)
  121.                       delflag t)
  122.               ) ;end progn
  123.               (progn
  124.                 (setq pt3 (nth ptcnt ptlist)
  125.                       ptcnt (1+ ptcnt)
  126.                       pt4 (nth ptcnt ptlist))
  127.               ) ;end progn
  128.             ) ;end if intersection
  129.           ) ;end repeat
  130.           (setq pt2 (nth pt2cnt pt2list)
  131.                 ptcnt 0
  132.                 pt2cnt (1+ pt2cnt)
  133.                 pt2a (nth pt2cnt pt2list))
  134.         ) ;end repeat
  135.         (if (= delflag nil)
  136.           (progn
  137.             (setq ptcnt 0 intcnt 0
  138.                   pt3 (nth 0 ptlist)
  139.                   pt4 (nth (1- (length ptlist)) ptlist))
  140.             (repeat (length ptlist)  ;check intersections of 1st point of line
  141.               (if (inters pt1 pt2 pt3 pt4) (setq intcnt (1+ intcnt)))
  142.               (setq pt3 (nth ptcnt ptlist)
  143.                     ptcnt (1+ ptcnt)
  144.                     pt4 (nth ptcnt ptlist))
  145.             ) ;end repeat
  146.             (if (or (= intcnt 0) (= (rem intcnt 2) 0)) ;if intersect even number
  147.               (progn ; then 1st point of line is not within boundary
  148.                 (ssdel (ssname entset cnt) entset)
  149.                 (setq cnt (1- cnt) delflag t)
  150.               ) ;end progn
  151.             ) ;enf if even number of intersections
  152.           ) ;end progn if delflag set
  153.         ) ;end if
  154.       ) ;end cond pline
  155.  
  156.       (t 
  157.          (ssdel (ssname entset cnt) entset)
  158.          (setq cnt (1- cnt))
  159.       ) ;end cond other entity types
  160.     ) ;end cond
  161.   ) ;end repeat sset
  162.   (if (> (sslength entset) 0)
  163.     (setq entset entset)
  164.     (prin1 "\n0 entities found. \n")
  165.   )
  166. ) ;end defun
  167. 
  168.